home *** CD-ROM | disk | FTP | other *** search
/ A.C.E. 2 / ACE CD 2.iso / FILES / UTILS / HSBASIC2.DMS / in.adf / HB2Examples2.0.Lha / Examples / GadtoolsGadgets / gadtoolsgadgets.bas < prev    next >
Encoding:
BASIC Source File  |  1994-04-29  |  11.3 KB  |  348 lines
  1.  
  2. '' gadtoolsgadgets.bas
  3. ''
  4. '' Simple example of using a number of gadtools gadgets.
  5. '' Derived from RKM example (c) Copyright 1992 Commodore-Amiga, Inc.
  6. '' Extended to show a ListView gadgets
  7. '' 
  8.  
  9. DEFINT a-z
  10.  
  11. 'REM $include intuition.bh
  12. 'REM $include gadtools.bh
  13. 'REM $include graphics.bh
  14. 'REM $include exec.bh
  15. REM $include Blib/ExecSupport.bas
  16.  
  17. LIBRARY OPEN "intuition.library",37
  18. LIBRARY OPEN "gadtools.library",37
  19. LIBRARY OPEN "graphics.library",37
  20. LIBRARY OPEN "exec.library"
  21.  
  22. ' we are going to do our own event handling
  23. REM $NOEVENT
  24. ' Gadget defines of our choosing, to be used as GadgetID's,
  25. ' also used as the index into the gadget array my_gads().
  26. '
  27. CONST MYGAD_SLIDER=0
  28. CONST MYGAD_STRING1=1
  29. CONST MYGAD_STRING2=2
  30. CONST MYGAD_STRING3=3
  31. CONST MYGAD_BUTTON=4
  32. CONST MYGAD_LISTVIEW=5
  33.  
  34. ' Range for the slider: 
  35. CONST SLIDER_MIN=1
  36. CONST SLIDER_MAX=20
  37.  
  38.  
  39. SUB InitTextAttr(T(1),FontName$,BYVAL Height,BYVAL style,BYVAL flags)
  40. POKEL VARPTR(T(0))+ta_Name%,SADD(FontName$+CHR$(0))
  41. t(ta_YSize\2)=Height
  42. POKEB VARPTR(T(0))+ta_Style,style
  43. POKEB VARPTR(T(0))+ta_Flags,flags
  44. END SUB
  45.  
  46. DIM SHARED temptag&(40)
  47. DIM SHARED Topaz80(4)
  48. DIM SHARED junk&
  49. InitTextAttr Topaz80(),"topaz.font",8,0,0
  50. gadtoolswindow
  51.  
  52. ' Subprogram to handle a GADGETUP or GADGETDOWN event.  For GadTools gadgets,
  53. ' it is possible to use this function to handle MOUSEMOVEs as well, with
  54. ' little or no work.
  55. '
  56. SUB HandleGadgetEvent(BYVAL win&, BYVAL gad&, BYVAL code, slider_level, my_gads&(1))
  57. STATIC gid
  58. gid=PEEKW(gad&+gadgetgadgetid)
  59. SELECT CASE Gid
  60.     CASE MYGAD_SLIDER:
  61.      '    Sliders report their level in the IntuiMessage Code field: 
  62.         PRINT "Slider at level ", code
  63.         slider_level = code
  64.     CASE MYGAD_STRING1:
  65.         PRINT "String gadget 1: '"; PEEK$(PEEKL(PEEKL(gad&+GadgetSpecialInfo)+StringInfoBuffer));"'"
  66.     CASE MYGAD_STRING2:
  67.         PRINT "String gadget 2: '"; PEEK$(PEEKL(PEEKL(gad&+GadgetSpecialInfo)+StringInfoBuffer));"'"
  68.     CASE MYGAD_STRING3:
  69.         PRINT "String gadget 3: '"; PEEK$(PEEKL(PEEKL(gad&+GadgetSpecialInfo)+StringInfoBuffer));"'"
  70.     CASE MYGAD_BUTTON:
  71.         PRINT "Button was pressed, slider reset to 10."
  72.         slider_level = 10
  73.     TAGLIST VARPTR(temptag&(0)),GTSL_Level&,slider_level,TAG_END&
  74.         GT_SetGadgetAttrsA my_gads&(MYGAD_SLIDER), win&, 0,VARPTR(temptag&(0))
  75.     CASE MYGAD_LISTVIEW:
  76.         PRINT "List line";code; "selected"
  77.     END SELECT
  78. END SUB
  79.  
  80.  
  81. ' Subprogram to handle vanilla keys.
  82. SUB HandleVanillaKey(BYVAL win&, BYVAL code, slider_level,my_gads&(1))
  83. SELECT CASE code
  84.     CASE "v"%
  85.         ' increase slider level, but not past maximum 
  86.         INCR slider_level
  87.         IF slider_level> SLIDER_MAX THEN slider_level=SLIDER_MAX
  88.         TAGLIST VARPTR(temptag&(0)),GTSL_Level&,slider_level,TAG_END&
  89.         GT_SetGadgetAttrsA my_gads&(MYGAD_SLIDER), win&, 0,VARPTR(temptag&(0))
  90.     CASE "V"%
  91.         DECR slider_level
  92.         IF slider_level< SLIDER_MIN THEN slider_level=SLIDER_MIN
  93.         TAGLIST VARPTR(temptag&(0)),GTSL_Level&,slider_level,TAG_END&
  94.         GT_SetGadgetAttrsA my_gads&(MYGAD_SLIDER), win&, 0,VARPTR(temptag&(0))
  95.     CASE "c"%,"C"%:
  96.         slider_level = 10
  97.         TAGLIST VARPTR(temptag&(0)),GTSL_Level&,slider_level,TAG_END&
  98.         GT_SetGadgetAttrsA my_gads&(MYGAD_SLIDER), win&, 0,VARPTR(temptag&(0))
  99.     CASE "f"%,"F"%:  junk&=ActivateGadget&( my_gads&(MYGAD_STRING1), win&, 0)
  100.     CASE "s"%,"S"%:  junk&=ActivateGadget&( my_gads&(MYGAD_STRING2), win&, 0)
  101.     CASE "t"%,"T"%:  junk&=ActivateGadget&( my_gads&(MYGAD_STRING3), win&, 0)
  102. END SELECT
  103. END SUB
  104.  
  105. SUB Setng_GadgetText(a$)
  106. SHARED ng(1)
  107. POKEL VARPTR(ng(ng_GadgetText\2)),SADD(a$+CHR$(0))
  108. END SUB
  109.  
  110. SUB Setng_ArrayName(BYVAL fieldoffset,arr(1))
  111. SHARED ng(1)
  112. POKEL VARPTR(ng(fieldoffset\2)),VARPTR(arr(0))
  113. END SUB
  114.  
  115. ' Add a name value$ to an ExecList listh&
  116. ' this should really copy value$=CHR$(0) to some AllocMem&ed memory
  117. ' as this won't work once a garbage collection has happened.
  118. SUB AddName(listh&,value$)
  119. STATIC namenode&
  120.     namenode&=AllocMem&(node_sizeof,MEMF_CLEAR&)
  121.     IF namenode&=0 THEN ERROR 7    ' out of memory
  122.     POKEL namenode&+ln_Name, SADD(value$+CHR$(0))
  123.     AddHead listh&,namenode&
  124. END SUB
  125.  
  126. ' Create the whole listview gadget
  127. FUNCTION CreateListGadget&
  128. STATIC i,Listhead&
  129. listhead&=AllocMem&(list_sizeof,MEMF_CLEAR&)
  130. NewList listhead&
  131. FOR i=15 TO 0 STEP -1
  132.     AddName    listhead&,"line"+STR$(i)
  133. NEXT i
  134. CreateListGadget&=listhead&
  135. END FUNCTION
  136.  
  137. ' Free the listview gadget and all its nodes
  138. SUB FreeListGadget(BYVAL listhead&)
  139. STATIC worknode&,nextnode&
  140. worknode&=PEEKL(ListHead&+lh_head)
  141. DO
  142.     nextnode&=PEEKL(worknode&+ln_Succ)
  143.     IF nextnode&=0 THEN EXIT LOOP
  144.     FreeMem worknode&,node_sizeof
  145.     worknode&=nextnode&
  146. LOOP
  147. END SUB
  148.     
  149.  
  150. FUNCTION CreateAllGadgets&(glistptr&, BYVAL vi&, BYVAL thetopborder, slider_level, my_gads&(1))
  151. SHARED ng(1),listviewlist&
  152. STATIC gad&
  153. STATIC gadgettags&(1)
  154. gad& = CreateContext&(VARPTR(glistptr&))
  155.  
  156. ' Since the NewGadget structure is unmodified by any of the CreateGadgetA()
  157. ' calls, we need only change those fields which are different.
  158. '
  159. DIM ng(NewGadget_sizeof\2)
  160. DIM GadgetTags&(20)
  161.  
  162. ng(ng_LeftEdge\2)   = 140
  163. ng(ng_TopEdge\2)    = 20+thetopborder
  164. ng(ng_Width\2)      = 200
  165. ng(ng_Height\2)     = 12
  166. Setng_GadgetText "_Volume:   "
  167. Setng_ArrayName ng_TextAttr,topaz80()
  168. POKEL VARPTR(ng(ng_visualInfo\2)),vi&
  169. ng(ng_GadgetID\2)  = MYGAD_SLIDER
  170. ng(ng_Flags\2)      = NG_HIGHLABEL&
  171.  
  172.   TAGLIST VARPTR(GadgetTags&(0)), _
  173.                     GTSL_Min&,         SLIDER_MIN, _
  174.                     GTSL_Max&,         SLIDER_MAX, _
  175.                     GTSL_Level&,       slider_level, _
  176.                     GTSL_LevelFormat&, "%2ld", _
  177.                     GTSL_MaxLevelLen&, 2, _
  178.                     GT_Underscore&,    "_"%, _
  179.                     TAG_END&
  180.  gad& = CreateGadgetA&(SLIDER_KIND&, gad&, VARPTR(ng(0)), VARPTR(gadgetTags&(0)))
  181.  my_gads&(MYGAD_SLIDER) = gad&
  182.  
  183. ng(ng_TopEdge\2)   = ng(ng_TopEdge\2) +20
  184. ng(ng_Height\2)    = 14
  185. Setng_GadgetText  "_First:"
  186. ng(ng_GadgetID\2) = MYGAD_STRING1
  187.   TAGLIST VARPTR(GadgetTags&(0)), _
  188.                     GTST_String&,   "Try pressing", _
  189.                     GTST_MaxChars&, 50, _
  190.                     GT_Underscore&, "_"%, _
  191.                     TAG_END&
  192.  gad& = CreateGadgetA&(STRING_KIND&, gad&, VARPTR(ng(0)), VARPTR(gadgetTags&(0)))
  193. my_gads&(MYGAD_STRING1) = gad&
  194.  
  195. ng(ng_TopEdge\2)   = ng(ng_TopEdge\2) +20
  196. Setng_GadgetText   "_Second:"
  197. ng(ng_GadgetID\2) = MYGAD_STRING2
  198.   TAGLIST VARPTR(GadgetTags&(0)), _
  199.                     GTST_String&,   "TAB or Shift-TAB", _
  200.                     GTST_MaxChars&, 50, _
  201.                     GT_Underscore&, "_"% , _
  202.                     TAG_END&
  203.  gad& = CreateGadgetA&(STRING_KIND&, gad&, VARPTR(ng(0)), VARPTR(gadgetTags&(0)))
  204. my_gads&(MYGAD_STRING2) = gad&
  205.  
  206. ng(ng_TopEdge\2)   = ng(ng_TopEdge\2) +20
  207. Setng_GadgetText   "_Third:"
  208. ng(ng_GadgetID\2) = MYGAD_STRING3
  209.   TAGLIST VARPTR(GadgetTags&(0)), _
  210.                     GTST_String&,   "To see what happens!", _
  211.                     GTST_MaxChars&, 50, _
  212.                     GT_Underscore&, "_"% , _
  213.                     TAG_END&
  214.  gad& = CreateGadgetA&(STRING_KIND&, gad&, VARPTR(ng(0)), VARPTR(gadgetTags&(0)))
  215. my_gads&(MYGAD_STRING3) = gad&
  216.  
  217. ng(ng_LeftEdge\2)=ng(ng_LeftEdge\2) + 50
  218. ng(ng_TopEdge\2)   = ng(ng_TopEdge\2) +20
  219. ng(ng_Width\2)      = 100
  220. ng(ng_Height\2)     = 12
  221. Setng_GadgetText  "_Click Here"
  222. ng(ng_GadgetID\2)   = MYGAD_BUTTON
  223. ng(ng_Flags\2)      = 0
  224.   TAGLIST VARPTR(GadgetTags&(0)), GT_Underscore&, "_"%, TAG_END&
  225.  gad& = CreateGadgetA&(BUTTON_KIND&, gad&, VARPTR(ng(0)), VARPTR(gadgetTags&(0)))
  226.  
  227. ng(ng_LeftEdge\2)   = 400
  228. ng(ng_TopEdge\2)    = 20+thetopborder
  229. ng(ng_Width\2)      = 150
  230. ng(ng_Height\2)     = 50
  231. Setng_GadgetText  "A list of lines"
  232. ng(ng_GadgetID\2)   = MYGAD_LISTVIEW
  233. ng(ng_Flags\2)      = 0
  234.   
  235.   listviewlist&=CreateListGadget&
  236.   TAGLIST VARPTR(GadgetTags&(0)), GT_Underscore&, "_"%, GTLV_Labels&, listviewlist&, TAG_END&
  237.  gad& = CreateGadgetA&(LISTVIEW_KIND&, gad&, VARPTR(ng(0)), VARPTR(gadgetTags&(0)))
  238.  
  239. CreateAllGadgets&=gad&
  240. END FUNCTION
  241.  
  242. ' Standard message handling loop with GadTools message handling functions
  243. ' used (GT_GetIMsg&() and GT_ReplyIMsg).
  244. SUB  Process_window_events(BYVAL mywin&, slider_level, my_gads&())
  245. STATIC imsg&
  246. STATIC imsgClass&
  247. STATIC imsgCode
  248. STATIC gad&
  249. STATIC terminated
  250. terminated=0
  251.  
  252. WHILE terminated=0
  253.     junk&= xWait&(1& << PEEKB(PEEKL(mywin&+UserPort)+mp_SigBit))
  254.  
  255.      DO
  256.        imsg& = GT_GetIMsg(PEEKL(mywin&+UserPort))
  257.        IF imsg&=0  THEN EXIT LOOP
  258.         gad& = PEEKL(imsg&+IAddress)
  259.  
  260.         imsgClass& =PEEKL(imsg&+Class)
  261.         imsgCode =PEEKW(imsg&+IntuiMessageCode)
  262.  
  263.         GT_ReplyIMsg imsg&
  264.         SELECT CASE imsgClass&
  265.             CASE IDCMP_GADGETDOWN&, IDCMP_MOUSEMOVE&, IDCMP_GADGETUP&:
  266.                 HandleGadgetEvent mywin&, gad&, imsgCode, slider_level, my_gads&()
  267.             CASE IDCMP_VANILLAKEY&:
  268.                 HandleVanillaKey mywin&, imsgCode, slider_level, my_gads&()
  269.             CASE IDCMP_CLOSEWINDOW&:
  270.                 terminated = 1
  271.             CASE IDCMP_REFRESHWINDOW&:
  272.                 GT_BeginRefresh mywin&
  273.                 GT_EndRefresh mywin&, TRUE&
  274.         END SELECT
  275.     LOOP UNTIL terminated
  276. WEND
  277. END SUB
  278.  
  279. ' Prepare for using GadTools, set up gadgets and open window.
  280. ' Clean up and when done or on error.
  281.  
  282. SUB GadtoolsWindow
  283. STATIC glist&
  284. STATIC font&
  285. STATIC mysc&
  286. STATIC mywin&
  287. DIM my_gads&(4)
  288. STATIC vi&
  289. STATIC slider_level
  290. STATIC thetopborder
  291. SHARED listviewlist&
  292. slider_level=5
  293. ' Open topaz 8 font, so we can be sure it's openable
  294. ' when we later set ng_TextAttr to &Topaz80:
  295. '
  296. font& = OpenFont(VARPTR(Topaz80(0)))
  297. IF font& = 0 THEN
  298.     PRINT  "Failed to open Topaz 80": STOP
  299. ELSE
  300.     mysc& = LockPubScreen(0)
  301.     IF mysc&=0 THEN
  302.         PRINT "Couldn't lock public screen"
  303.     ELSE
  304.         TAGLIST VARPTR(temptag&(0)), TAG_END&
  305.         vi& = GetVisualInfoA&(mysc&, VARPTR(temptag&(0)))
  306.         IF vi& = 0 THEN
  307.             PRINT "GetVisualInfo failed"
  308.         ELSE
  309.             ' Here is how we can figure out ahead of time how tall the  
  310.             ' window's title bar will be:
  311.             thetopborder =  PEEKB(mysc&+WBorTop) + PEEKW(PEEKL(mysc&+ScreenFont)+ta_YSize) + 1
  312.             IF CreateAllGadgets&(glist&,vi&,thetopborder,slider_level,my_gads&())=0 THEN
  313.                 PRINT "CreateAllGadgets failed"
  314.             ELSE
  315.                 TAGLIST VARPTR(temptag&(0)), _
  316.                         WA_Title&,     "GadTools Gadget Demo", _
  317.                         WA_Gadgets&,   glist&,      WA_AutoAdjust&,    TRUE&, _
  318.                         WA_Width&,       600&,      WA_MinWidth&,        50&, _
  319.                         WA_InnerHeight&, 140&,      WA_MinHeight&,       50&, _
  320.                         WA_DragBar&,    TRUE&,      WA_DepthGadget&,   TRUE&, _
  321.                         WA_Activate&,   TRUE&,      WA_CloseGadget&,   TRUE&, _
  322.                         WA_SizeGadget&, TRUE&,      WA_SimpleRefresh&, TRUE&, _
  323.                         WA_IDCMP&, IDCMP_CLOSEWINDOW&+IDCMP_REFRESHWINDOW&+ _
  324.                             IDCMP_VANILLAKEY&+ SLIDERIDCMP&+ STRINGIDCMP&+ BUTTONIDCMP&, _
  325.                         WA_PubScreen&, mysc&, _
  326.                         TAG_END&
  327.                 mywin& = OpenWindowTagList&(0,VARPTR(temptag&(0)))
  328.                 IF mywin&=0 THEN 
  329.                     PRINT "OpenWindow failed"
  330.                 ELSE
  331.                     GT_RefreshWindow mywin&, 0
  332.                     process_window_events mywin&, slider_level, my_gads&()
  333.  
  334.                     CloseWindow mywin&
  335.                 END IF
  336.             END IF
  337.             FreeGadgets glist&
  338.             FreeListGadget    listviewlist&
  339.             FreeVisualInfo vi&
  340.         END IF
  341.         UnlockPubScreen 0, mysc&
  342.     END IF
  343.     CloseFont font& 
  344. END IF
  345. END SUB
  346.  
  347.  
  348.